IF BLOCK.TYPE$ = "L" THEN GOSUB READTOLINE ELSE IF BLOCK.TYPE$ = "S" THEN GOSUB READTOSTRING ELSE IF BLOCK.TYPE$ = "LABEL" OR BLOCK.TYPE$ = "LABEL#" THEN GOSUB READTOLABEL ELSE M$ = "WARNING: ILLEGAL BLOCK TYPE ": _
W$ = BLOCK.TYPE$: CALL WRMIS(M$, W$)
RETURN
READTOLINE:
REM READS UPTO LINE DESIRED.PTR IN OLD
WHILE PTR% < DESIRED.PTR AND NOT EOF(1)
GOSUB READOLD
PTR% = PTR% + PTR.INCREMENT%
IF LINE.DISP$ = "K" THEN CALL WRITENEW(TRANS$, NWRITE, REMOVE.COMMENTS) ' 06-06
WEND
RETURN
READTOSTRING:
REM READS UPTO A STRING IN OLD
TRANS$ = TARGET$
IF NOT EOF(1) THEN GOSUB READOLD
WHILE INSTR(TRANS$, TARGET$) = 0
PTR% = PTR% + 1
IF LINE.DISP$ = "K" THEN CALL WRITENEW(TRANS$, NWRITE, REMOVE.COMMENTS) ' 06-06
IF NOT EOF(1) THEN GOSUB READOLD ELSE M$ = "WARNING: STRING " + TARGET$ + " NOT FOUND": W$ = "": CALL WRMIS(M$, W$): TRANS$ = TARGET$
WEND
PREV.OLD$ = TRANS$
RETURN
READTOLABEL:
REM READS UPTO A LABEL IN OLD
IF IGNORECASE THEN CALL UPCASE(TARGET$)
IF BLOCK.TYPE$ = "LABEL" AND RIGHT$(TARGET$, 1) <> END.LABEL$ THEN TARGET$ = TARGET$ + END.LABEL$
IF NOT EOF(1) THEN GOSUB READOLD: GOSUB GETFIRSTWORD ELSE FIRST.WORD$ = TARGET$: TRANS$ = ""
WHILE FIRST.WORD$ <> TARGET$
PTR% = PTR% + 1
IF LINE.DISP$ = "K" THEN CALL WRITENEW(TRANS$, NWRITE, REMOVE.COMMENTS) ' 06-06
IF NOT EOF(1) THEN GOSUB READOLD: GOSUB GETFIRSTWORD ELSE M$ = "WARNING: LABEL " + TARGET$ + " NOT FOUND": W$ = "": CALL WRMIS(M$, W$): FIRST.WORD$ = TARGET$
WEND
PREV.OLD$ = TRANS$
RETURN
GETFIRSTWORD:
CALL FIRSTWORD(TRANS$, FIRST.WORD$, BEGIN.AT)
IF IGNORECASE THEN CALL UPCASE(FIRST.WORD$)
RETURN
READOLD:
REM FETCHES NEXT UNPROCESSED RECORD FROM OLD
IF PTR% <= NREAD THEN TRANS$ = PREV.OLD$ ELSE GOSUB READOLDREC
RETURN
READOLDREC:
LINE INPUT #1, TRANS$
NREAD = NREAD + 1
LOCATE MROW, MCOL: PRINT NREAD;
RETURN
WRNTIMES:
REM WRITES EXACTLY N RECORDS FROM TRANSACTION FILE
REM GET BLKTYPE$ - HOW BLOCK DEFINED (LINE,STRING,LABEL)
REM DES.NO% - DESIRED LINE NUMBER FOR LINE BLOCK TYPE
REM TARGET$ - TARGET STRING FOR STRING/LABEL BLOCK TYPE
REM INCMT% - FLAG SET TO 0 WHEN BLOCK EXTENDS TO END-OF-FILE,
REM OTHERWISE 1
REM NUWRD% - LAST WORD POSITION THIS ROUTINE EXAMINED
REM PRINT "SUB CHKWRDS RECEIVED BEG=";BEG%;" PTR=";PTR%
TARGET$ = ""
INCMT% = 1
DES.NO% = 0
IF BEG% < 1 THEN BEG% = 1: PRINT "UPPED BEG%"
REM IF PTR%<10 THEN PTR%=10:PRINT "UPPED PTR%"
WD$ = WRDS$(BEG%)
FLET$ = LEFT$(WD$, 1)
IF FLET$ <> "L" AND FLET$ <> "S" THEN BLKTYPE$ = "L": NUWRD% = BEG% ELSE NUWRD% = BEG% + 1: IF WD$ = "LABEL" OR WD$ = "LABEL#" THEN BLKTYPE$ = "LABEL": TARGET$ = WRDS$(NUWRD%) ELSE IF FLET$ = "S" THEN BLKTYPE$ = "S": TARGET$ = _
WRDS$(NUWRD%) ELSE BLKTYPE$ = "L"
WD$ = WRDS$(NUWRD%)
L2$ = LEFT$(WD$, 2)
RES$ = MID$(WD$, 3)
IF BLKTYPE$ = "L" THEN IF L2$ = "*+" THEN CALL NUMERIC(RES$, POSNUM): IF POSNUM THEN DES.NO% = VAL(RES$) + PTR% ELSE M$ = "NON-NUMERIC IN LINE NUMBER FIELD": CALL WRMIS(M$, WD$) ELSE IF L2$ = "*" THEN DES.NO% = _
PTR% ELSE CALL NUMERIC(WD$, POSNUM): IF POSNUM THEN DES.NO% = VAL(WD$) ELSE IF WD$ = "END" THEN INCMT% = 0 ELSE M$ = "NON-NUMERIC IN LINE NUMBER FIELD": CALL WRMIS( _
M$, WD$)
IF BLKTYPE$ <> "L" AND TARGET$ = "" THEN M$ = "STRING/LABEL MISSING": CALL WRMIS(M$, WD$)
REM PRINT "CHKWRDS RETURNED DESNO=";DES.NO%;" NUWRD=";NUWRD%
END SUB
SUB CREDITS STATIC
REM PUTS UP CREDITS WHEN PROGRAM INVOKED
REM DEFINT A-Z
SEC = 3
CLS
KEY OFF
RO = 1: CO = 12: X$ = "BLED - A SOURCE CODE MERGE UTILITY ver 2.2 May 16, 1989"'03-20-88
CALL QPRINT(X$, RO, CO)
RO = 3: CO = 3: X$ = "Copyright (c) 1985-88 Ken Goosens, 5020 Portsmouth Rd, Fairfax, VA 22032"
CALL QPRINT(X$, RO, CO)
RO = 6: CO = 2: X$ = "You are granted a limited license to use and distribute this program provided"
CALL QPRINT(X$, RO, CO)
RO = 8: CO = 10: X$ = "1. you do not alter or remove this notice"
CALL QPRINT(X$, RO, CO)
RO = 10: CO = 10: X$ = "2. you receive no fee or charge for this program"
CALL QPRINT(X$, RO, CO)
RO = 12: CO = 10: X$ = "3. modifications are distributed only as a merge to this program"
CALL QPRINT(X$, RO, CO)
RO = 14: CO = 10: X$ = "4. you assume all liability for using this program"
CALL QPRINT(X$, RO, CO)
LOCATE 16, 1: CALL PRTHELP
CALL WAITSECORKEY(SEC)
END SUB
SUB ECHO (STRNG$, ROW%, COL%, FLDSIZE%) STATIC
REM ROUTINE FOR CLEARING A SPACE AND PRINTING MESSAGE
CALL QPRINT(SPACE$(FLDSIZE%), ROW%, COL%)
CALL QPRINT(STRNG$, ROW%, COL%)
END SUB
SUB ENDNB (STRNG$, LST%) STATIC
REM LOCATES LAST NON-BLANK CHARACTER IN STRNG$. 0 IF NONE.
REM PASS STRNG$ - STRING TO BE SEARCHED
REM GET LST% - POSITION IN STRNG$ OF LAST NON-BLANK
REM DOES FULL SCREEN DATA ENTRY FOR TABLE DRIVEN SCREEN
REM DEFINT A-Z
NUL$ = ""
TOPGETSCRN:
FOR I = 1 TO NUMFLDS%
CALL EXPLAIN(HLP$(I))
X = INSTR("LSN", FLDTYPE$(I))
IF X > 1 THEN IF X = 2 THEN CALL GETSTR(ROW%(I), COL%(I), PROMPT$(I), FLDSIZE%(I), FLDVAL$(I)) ELSE CALL GETNATNUM(ROW%(I), COL%(I), PROMPT$(I), FLDSIZE%(I), FLDVAL$(I))
NEXT I
END SUB
SUB GETSTR (ROW%, COL%, PROMPT$, FLDSIZE%, RESULT$) STATIC
REM INPUT ROUTINE TO GET A STRING
REM LOCATE 24,70:PRINT "GETSTR ";
X% = FLDSIZE% + 1: IF X% < 8 THEN X% = 8
CALL QPRINT(PROMPT$ + SPACE$(X%), ROW%, COL%)
X% = COL% + LEN(PROMPT$) + 1
CALL ECHO(RESULT$, ROW%, X%, FLDSIZE%)
LOCATE ROW%, X%
INPUT "", X$
IF X$ <> "" THEN RESULT$ = X$: CALL ECHO(RESULT$, ROW%, X%, FLDSIZE%)
END SUB
SUB GETTRANS (FILENO%, TRANS$, NTRANS%) STATIC ' 2.0
REM FETCHES TRANSACTION RECORD
REM PASS NTRANS% - VALUE OF 0 TO INITIALIZE COUNTER, OTHERWISE > 0
REM GET TRANS% - NEW TRANSACTION RECORD
REM DEFINT A-Z
LINE INPUT #FILENO%, TRANS$ ' 2.0
IF NTRANS% < 1 THEN LOCTRANS = 0: NTRANS% = 1
LOCTRANS = LOCTRANS% + 1
LOCATE 24, 31: PRINT LOCTRANS%;
END SUB
SUB INQUOTES (STRNG$, BS%, INQUO%) STATIC
REM CHECKS WHETHER CHARACTER AT POSITION BS% IN STRNG$
REM IS INSIDE A PAIR OF QUOTES. RETURNS POSITION OF RIGHT QUOTE
REM IF INSIDE, 0 IF NOT INSIDE
REM DEFINT A-Z
QUOTE$ = CHR$(34)
BEG = 1
INQUO% = 0
CHKQAGAIN:
FQUO = INSTR(BEG, STRNG$, QUOTE$)
IF FQUO = 0 THEN GOTO GETOUTINQUOTES
IF BS% <= FQUO THEN GOTO GETOUTINQUOTES
SQUO = INSTR(FQUO + 1, STRNG$, QUOTE$)
IF SQUO = 0 THEN GOTO GETOUTINQUOTES
IF BS% < SQUO THEN INQUO% = SQUO: GOTO GETOUTINQUOTES
BEG = SQUO + 1
GOTO CHKQAGAIN
GETOUTINQUOTES:
REM PRINT "INQUOTES: LOOKING AT POS ";BS%;"<";MID$(STRNG$,BS%,1);"> SENDING INQUO=";INQUO%
END SUB
SUB KEEPONLY (L$, GOODSTRNG$) STATIC
REM KEEPS IN L$ ONLY THOSE CHARACTERS IN GOODSTRNG$, I.E.
REM REMOVES FROM L$ ALL INSTANCES OF CHARACTERS NOT IN GOODSTRNG$
REM PASS L$ - STRING TO BE ALTERED
REM GOODSTRNG$ - LIST OF CHARACTERS TO KEEP
REM GET L$ - ORIGINAL MINUS CHARS NOT IN GOODSTRNG$
REM DEFINT A-Z
J = 0
FOR I = 1 TO LEN(L$)
IF INSTR(GOODSTRNG$, MID$(L$, I, 1)) THEN J = J + 1: MID$(L$, J, 1) = MID$(L$, I, 1)
NEXT I
L$ = LEFT$(L$, J)
END SUB
SUB LASTNB (STRNG$, BEG%, WHEREIS%) STATIC
REM PASS STRNG$ - A STRING TO BE SEARCHED
REM BEG% - POSITION TO BEGIN SEARCH
REM GET WHEREIS% - LAST POSITION IN STRNG$ OF ANY WORD BEGINNING AT
REM BEG% OR LATER. RETURNS BEG%-1 IF NO WORD AT BEG%.
REM DEFINT A-Z
REM LOCATE 24,70:PRINT "LASTNB ";
B = BEG%
IF B < 1 THEN B = 1
IF B > LEN(STRNG$) THEN X$ = " " ELSE X$ = MID$(STRNG$, B) + " "
WHEREIS% = INSTR(X$, " ") - 1 + B - 1
END SUB
SUB NOOTHER (STRNG$, ONLY$, RESULT%) STATIC
REM PASS STRNG$ - A STRING TO BE SEARCHED
REM ONLY$ - A LIST OF THE ONLY CHARACTERS TO BE IN STRNG$
REM GET RESULT% - TRUE OF ONLY CHARACTERS IN STRNG$ ARE THOSE IN ONLY$
REM OR ARE LEADING OR TRAILING BLANKS
REM DEFINT A-Z
RESULT% = -1
IF LEN(STRNG$) < 1 THEN GOTO GETOUTNOOTHER
ONE = 1
CALL FIRSTNB(STRNG$, ONE, BS)
CALL LASTNB(STRNG$, BS, ES)
FOR I = BS TO ES
IF INSTR(ONLY$, MID$(STRNG$, I, 1)) = 0 THEN
RESULT% = 0
I = ES + 1
END IF
NEXT I
IF STRNG$ <> MID$(STRNG$, 1, ES) + SPACE$(LEN(STRNG$) - ES) THEN RESULT% = 0
GETOUTNOOTHER:
END SUB
SUB NUMERIC (STRNG$, RESULT%) STATIC
REM PASS STRNG$ - A STRING TO BE SEARCHED
REM GET RESULT% - TRUE IF STRNG$ CONTAINS ONLY NON-NEGATIVE DIGITS
REM OR LEADING OR TRAILING BLANKS
REM DEFINT A-Z
IF STRNG$ = SPACE$(LEN(STRNG$)) THEN RESULT% = 0: GOTO GETOUTNUMERIC
